home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0514.ZIP / CRAYZ15.ARC / MPBLAS.PAS < prev    next >
Pascal/Delphi Source File  |  1986-09-15  |  6KB  |  197 lines
  1. { Copyright (C) 1986 Adam Fritz, 133 Main St., Afton, NY 13730 }
  2.  
  3. function ISAMAX (      n : integer ;
  4.                   var sx : real ;
  5.                     incx : integer ) : integer ;
  6.  
  7.      { Find index of element having maximum absolute value.}
  8.      {                                                     }
  9.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  10.  
  11. var
  12.      smax           : real ;
  13.      i, ix          : integer ;
  14.      x              : RowPointer ;
  15.  
  16. begin
  17.    ISAMAX := 0 ;
  18.    if n > 0 then begin
  19.       ISAMAX := 1 ;
  20.       if n > 1 then begin
  21.                                 { incx > 1 }
  22.          if incx > 1 then begin
  23.             x := Ptr(Seg(sx),Ofs(sx)) ;
  24.             ix := 1 ;
  25.             smax := Abs(x^.s[1]) ;
  26.             ix := ix + incx ;
  27.             for i := 2 to n do begin
  28.                if Abs(x^.s[ix]) > smax then begin
  29.                   ISAMAX := i ;
  30.                   smax := Abs(x^.s[ix])
  31.                end ;
  32.                ix := ix + incx
  33.             end
  34.          end
  35.                                 { incx = 1 }
  36.          else begin
  37.             MaxAVal (sx, smax, ix, n) ;
  38.             ISAMAX := ix
  39.          end
  40.       end
  41.    end
  42. end ;
  43.  
  44. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  45.  
  46. function SASUM (      n : integer ;
  47.                  var sx : real ;
  48.                    incx : integer ) : real ;
  49.  
  50.      { Forms sum of absolute values.                       }
  51.      {                                                     }
  52.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  53.  
  54. var
  55.      stemp          : real ;
  56.  
  57. begin
  58.    stemp := 0.0 ;
  59.    if n > 0 then
  60.                                 { incx > 1 }
  61.       if incx > 1 then
  62.          stemp := SumVABSSk (sx,incx,n)
  63.                                 { incx = 1 }
  64.       else
  65.          stemp := SumVABS (sx,n) ;
  66.    SASUM := stemp
  67. end ;
  68.  
  69. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  70.  
  71. procedure SAXPY (      n : integer ;
  72.                       sa : real ;
  73.                   var sx : real  ;
  74.                     incx : integer ;
  75.                   var sy : real  ;
  76.                     incy : integer ) ;
  77.  
  78.      { Compute constant times a vector plus a vector.      }
  79.      {                                                     }
  80.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  81.  
  82. var
  83.      i, ix, iy      : integer ;
  84.      x, y           : RowPointer ;
  85.  
  86. begin
  87.    if n > 0 then begin
  88.       if sa <> 0.0 then begin
  89.                                 { incx <> incy or incx <> 1 }
  90.          if (incx <> 1) or (incy <> 1) then begin
  91.             x := Ptr(Seg(sx),Ofs(sx)) ;
  92.             y := Ptr(Seg(sy),Ofs(sy)) ;
  93.             ix := 1 ;
  94.             iy := 1 ;
  95.             if incx < 0 then
  96.                ix := (-n + 1) * incx + 1 ;
  97.             if incy < 0 then
  98.                iy := (-n + 1) * incy + 1 ;
  99.             for i := 1 to n do begin
  100.                y^.s[iy] := y^.s[iy] + sa * x^.s[ix] ;
  101.                ix := ix + incx ;
  102.                iy := iy + incy
  103.             end
  104.          end
  105.                                       { incx, incy = 1 }
  106.          else
  107.             VAddKxV (sy,sy,sa,sx,n)
  108.       end
  109.    end
  110. end ;
  111.  
  112. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  113.  
  114. procedure SCOPY (      n : integer ;
  115.                   var sx : real ;
  116.                     incx : integer ;
  117.                   var sy : real ;
  118.                     incy : integer ) ;
  119.  
  120.      { Copies a vector, x, to a vector, y.                 }
  121.      {                                                     }
  122.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  123.  
  124. begin
  125.    if n > 0 then
  126.                                 { incx, incy  <> 1 }
  127.       if (incx <> 1) or (incy <> 1) then
  128.          CopyVSk (sy,incy,sx,incx,n)
  129.                                 { incx, incx = 1 }
  130.       else
  131.          CopyV (sy,sx,n)
  132. end ;
  133.  
  134. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  135.  
  136. function SDOT (      n : integer ;
  137.                 var sx : real ;
  138.                   incx : integer ;
  139.                 var sy : real ;
  140.                   incy : integer ) : real ;
  141.  
  142.      { Computes dot product of two vectors.                }
  143.      {                                                     }
  144.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  145.  
  146. begin
  147.    if n > 0 then
  148.       SDOT := DotProd (sx,incx,sy,incy,n)
  149.    else
  150.       SDOT := 0.0
  151. end ;
  152.  
  153. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  154.  
  155. procedure SSCAL (      n : integer ;
  156.                       sa : real ;
  157.                   var sx : real ;
  158.                     incx : integer ) ;
  159.  
  160.      { Computes vector scaled by a constant.               }
  161.      {                                                     }
  162.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  163.  
  164. begin
  165.    if n > 0 then
  166.                                 { incx <> 1 }
  167.       if incx <> 1 then
  168.          KxVSk (sx,incx,sa,sx,incx,n)
  169.                                 { incx = 1 }
  170.       else
  171.          KxV (sx,sa,sx,n)
  172. end ;
  173.  
  174. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  175.  
  176. procedure SSWAP (      n : integer ;
  177.                   var sx : real ;
  178.                     incx : integer ;
  179.                   var sy : real ;
  180.                     incy : integer ) ;
  181.  
  182.      { Interchanges two vectors.                           }
  183.      {                                                     }
  184.      { Adam Fritz, TURBO Pascal, 8/02/86.                  }
  185.  
  186. begin
  187.    if n > 0 then
  188.                                 { incx <> incy or incx <> 1 }
  189.       if (incx <> 1) or (incy <> 1) then
  190.          SwapVSk (sx,incx,sy,incy,n)
  191.                                 { incx, incy = 1 }
  192.       else
  193.          SwapV (sx,sy,n)
  194. end ;
  195.  
  196. { Copyright (C) 1986 Adam Fritz, 133 Main St., Afton, NY 13730 }
  197.